home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / progjour / 1987 / 06 / sheltool.pas < prev   
Pascal/Delphi Source File  |  1987-09-01  |  7KB  |  256 lines
  1. {$Z63,S3,V+,E1,W-,F1,T0}
  2. (* Copyright 1987, John J. Newlin *)
  3. implementation module sheltool(input,output);
  4.  
  5. function shiftl(target,bits : integer) : integer; external;
  6.  
  7. function shiftr(target,bits : integer) : integer; external;
  8.  
  9. function hi(target : integer) : integer; external;
  10.  
  11. function lo(target : integer) : integer; external;
  12.  
  13. function upcase(ch : char) : char; external;
  14.  
  15. procedure exec(var name : string); external;
  16.  
  17. function delete_file(addr : integer) : integer; external;
  18.  
  19. procedure longstr(var long : longint; var strng : longstring); external;
  20.  
  21. procedure save_cursor; external;
  22.  
  23. procedure hide_cursor; external;
  24.  
  25. procedure rest_cursor; external;
  26.  
  27. procedure addlong(var total,n1,n2 : longint); external;
  28.  
  29. function keycode(var status,ascii,scan : integer) : boolean; external;
  30.  
  31. procedure scroll(ulx,uly,lrx,lry,lines,attr,dir : integer); external;
  32.  
  33. procedure savebox(col,row,width,depth,attr : integer); external;
  34.  
  35. procedure restbox(col,row,width,depth,attr : integer); external;
  36.  
  37. procedure set_dta(var buffer : buff_type); external;
  38.  
  39. procedure init_screen; external;
  40.  
  41. procedure msdos(var regs : regtype); external;
  42.  
  43. procedure setxy(col,row : integer);  external;
  44.  
  45. procedure screenwrite(col,row,attr : integer; var str : string); external;
  46.  
  47. procedure fillstr(var str : string; num : integer; ch : char); external;
  48.  
  49. procedure move(v1addr,v2addr,bytes : integer); external;
  50.  
  51. function chdir(var dirname : string) : integer; external;
  52.  
  53. function mkdir(var dirname : string) : integer; external;
  54.  
  55. function rmdir(var dirname : string) : integer; external;
  56.  
  57. procedure getdir(var path : string); external;
  58.  
  59. function findfirst(var pathname : string; attr : integer) : integer; external;
  60.  
  61. function findnext : integer; external;
  62.  
  63. procedure cls(attribute : integer); external;
  64.  
  65. procedure strng(num : integer; var numstr : string); external;
  66.  
  67. function abs_read(drive,sectors,start,buff_addr:integer):integer; external;
  68.  
  69. function set_mem : integer; external;
  70.  
  71. function video_mode : integer; external;
  72.  
  73. procedure execute(var command : string);
  74. var l : integer;
  75. begin
  76.   l := length(command);
  77.   command := concat(" ",command," ");
  78.   command[1] := chr(l);
  79.   command[length(command)] := chr(13);
  80.   if length(command) > 126 then return;
  81.   savebox(1,1,80,25,address(screenbuff));
  82.   cls(15);
  83.   rest_cursor;
  84.   setxy(1,1);
  85.   exec(command);
  86.   hide_cursor;
  87.   restbox(1,1,80,25,address(screenbuff));
  88. end;
  89.  
  90. procedure draw_box(col,row,width,depth : integer);
  91. var x,y : integer;
  92.     side : string;
  93. begin
  94.   fillstr(side,width-2,horiz[1]);
  95.   side := concat(ul,side,ur);
  96.   screenwrite(col,row,main_color,side);
  97.   fillstr(side,width-2,space[1]);
  98.   side := concat(vert,side,vert);
  99.   for y := row+1 to row+depth-1 do screenwrite(col,y,main_color,side);
  100.   fillstr(side,width-2,horiz[1]);
  101.   side := concat(ll,side,lr);
  102.   screenwrite(col,row+depth,main_color,side);
  103. end;
  104.  
  105. procedure fx(barlen,battr,col,row,attr : integer; var str : string);
  106. begin
  107.   if barlen < length(str) then
  108.     begin
  109.       screenwrite(col,row,attr,str);
  110.       return;
  111.     end
  112.   else
  113.     begin
  114.       while length(str) < barlen do str := concat(str," ");
  115.       screenwrite(col,row,battr,str);
  116.     end;
  117. end;
  118.  
  119. procedure get_files(var mask : string; var files : file_array;
  120.                     var count : integer);
  121. var dir : buff_type;
  122. begin
  123.   set_dta(dir);
  124.   count := 0;
  125.   if findfirst(mask,16#1F#) = 0 then         {attr bit pattern = 00010111}
  126.      begin
  127.        if dir.filename[1] <> '.' then
  128.          begin
  129.            count := succ(count);
  130.            move(address(dir.attr),address(files[count]),22);
  131.            files[count].desig := 0;
  132.          end;
  133.      end;
  134.    while (count < maxfiles) and (findnext = 0) do
  135.      begin
  136.        if dir.filename[1] <> '.' then
  137.          begin
  138.            count := succ(count);
  139.            move(address(dir.attr),address(files[count]),22);
  140.            files[count].desig := 0;
  141.          end;
  142.      end;
  143. end;
  144.  
  145. function filedate(code : integer) : str12;
  146. var i,y,m,d : integer;
  147.     ys,ms,ds : str12;
  148. begin
  149.   y := hi(code);
  150.   y := shiftr(y,1) + 80;
  151.   if y > 99 then y := y - 100;
  152.   strng(y,ys);
  153.   m := shiftr(code,1);
  154.   m := lo(m);
  155.   m := shiftr(m,4);
  156.   strng(m,ms);
  157.   if length(ms) = 1 then ms := concat("0",ms);
  158.   d := shiftl(code,3);
  159.   d := lo(d);
  160.   d := shiftr(d,3);
  161.   strng(d,ds);
  162.   if length(ds) = 1 then ds := concat("0",ds);
  163.   filedate := concat(ms,"/",ds,"/",ys);
  164. end;
  165.  
  166. function filetime(code : integer) : str12;
  167. var h,m : integer;
  168.     hr,mi,x : str12;
  169. begin
  170.   h := hi(code);
  171.   h := shiftr(h,3);
  172.   if h >= 12 then
  173.     begin
  174.       if h > 12 then h := h - 12;
  175.       x := ' p.m.';
  176.     end else x := ' a.m.';
  177.   strng(h,hr);
  178.   if length(hr) = 1 then hr := concat("0",hr);
  179.   m := shiftr(code,6);
  180.   m := lo(m);
  181.   m := shiftl(m,3);
  182.   m := lo(m);
  183.   m := shiftr(m,2);
  184.   strng(m,mi);
  185.   if length(mi) = 1 then mi := concat("0",mi);
  186.   filetime := concat(hr,":",mi,x);
  187. end;
  188.  
  189. function convert(var st : str12) : str12;
  190. var n,i : integer;
  191.     name : string[13];
  192. begin
  193.   n := pos(".",st);
  194.   if (n > 0) and (n <> 9) then
  195.     begin
  196.       name := '            ';
  197.       move(address(st[1]),address(name[1]),n-1);
  198.       move(address(st[n]),address(name[9]),length(st)-n+1);
  199.     end 
  200.   else name := st;
  201.   name[9] := chr(32);
  202.   while length(name) < 12 do name := concat(name," ");
  203.   convert := name;
  204. end;
  205.  
  206. procedure sort_files(var files : file_array; var items : integer);
  207. var jump,i,j : integer;
  208.     done : boolean;
  209.     temp : file_type;
  210. begin
  211.   jump := items;
  212.   while jump > 1 do
  213.     begin
  214.       jump := jump div 2;
  215.       repeat
  216.         done := true;
  217.         for j := 1 to items - jump do
  218.           begin
  219.             i := j + jump;
  220.             if files[j].name > files[i].name then
  221.               begin
  222.                 temp := files[j];
  223.                 files[j] := files[i];
  224.                 files[i] := temp;
  225.                 done := false;
  226.               end;
  227.           end;
  228.       until done;
  229.     end;
  230. end;
  231.  
  232. function format_num(long : longint; width : integer) : string;
  233. var str : longstring;
  234.      n,i,temp : integer;
  235. begin
  236.   longstr(long,str);
  237.   n := length(str);
  238.   if n in [4..6] then insert(",",str,n-2);
  239.   if n in [7..9] then
  240.     begin
  241.       insert(",",str,n-5);
  242.       insert(",",str,n-1);
  243.     end;
  244.   n := length(str);
  245.   if width > n then for i := 1 to (width - n) do str := concat(" ",str);
  246.   format_num := str;
  247. end;
  248.  
  249. begin
  250.   entry_str := '';
  251.   color := video_mode <> 7;
  252.   if color then attr := 16#0B# else attr := 16#0F#;
  253.   init_screen;
  254. end.
  255.  
  256.